home *** CD-ROM | disk | FTP | other *** search
/ Nebula 1 / Nebula One.iso / Internet / WWW / Perl_WWW_Utilities / perlMIF_beta2 / mif / mif.pl < prev    next >
Encoding:
Perl Script  |  1994-07-05  |  10.2 KB  |  342 lines
  1. ##---------------------------------------------------------------------------##
  2. ##  File:
  3. ##      mif.pl
  4. ##  Author:
  5. ##      Earl Hood       ehood@convex.com
  6. ##  Description:
  7. ##      This file defines the "mif" perl package.  This file defines the
  8. ##    core routine "MIFread_mif()" to parse Frame MIF, and base routines
  9. ##    for outputing MIF.
  10. ##---------------------------------------------------------------------------##
  11. ##  Copyright (C) 1994  Earl Hood, ehood@convex.com
  12. ##
  13. ##  This program is free software; you can redistribute it and/or modify
  14. ##  it under the terms of the GNU General Public License as published by
  15. ##  the Free Software Foundation; either version 2 of the License, or
  16. ##  (at your option) any later version.
  17. ## 
  18. ##  This program is distributed in the hope that it will be useful,
  19. ##  but WITHOUT ANY WARRANTY; without even the implied warranty of
  20. ##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21. ##  GNU General Public License for more details.
  22. ##  
  23. ##  You should have received a copy of the GNU General Public License
  24. ##  along with this program; if not, write to the Free Software
  25. ##  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  26. ##---------------------------------------------------------------------------##
  27.  
  28. package mif;
  29.  
  30. $VERSION = "1.0.0";
  31.  
  32. ##-------------------##
  33. ## Markup characters ##
  34. ##-------------------##
  35. $mso    = '<';        # Markup statement open
  36. $msc    = '>';        # Markup statement close
  37. $stb    = '`';        # Mif string begin
  38. $ste    = "'";        # Mif string end
  39. $como    = '#';        # End-of-line comment open
  40. $ido    = '=';        # Import data opener
  41. $idlo    = '&';        # Import data line begin chars
  42. $idcstr    = '=EndInset';    # Import data close
  43.  
  44. ##----------------------##
  45. ## read_mif() variables ##
  46. ##----------------------##
  47. @OpenTokens = ();    # Stack of current open tokens
  48.  
  49. $MClose    = -1;        # Variable constants used as 2nd argument
  50. $MLine    =  0;        #    to token functions.
  51. $MOpen    =  1;        #    ...
  52.  
  53. $fast = 0;        # Flag if comments are skipped and not stripped
  54. $no_import_data = 0;    # Flag if import data should be checked
  55.  
  56. $rm_Ignore = 0;        # Determines if current statement is ignored
  57. $rm_Store = 0;        # Determines if current statement will be stored
  58.  
  59. $func =            # Calling token function
  60. $stline =        # Stored MIF if in store mode
  61. $stfunc =        # Store token function in store mode
  62. $carry =        # Carry over text to help preserve formatting
  63. $token = "";        # MIF token
  64.  
  65. ##----------------------------------------------------##
  66. ## Associative array mapping token names to functions ##
  67. ##----------------------------------------------------##
  68. %MIFToken = ();
  69. $MStore    = 'STORE';    # Special map value to tell MIFread_mif() to store
  70.             # MIF text unprocessed.
  71.  
  72. $MImportData = 'import_data';
  73.             # Name of token for imported data.
  74.  
  75. ##---------------------------------------------------------------------------##
  76. ##    MIFread_mif() reads MIF from filehandle $handle.
  77. ##
  78. sub main'MIFread_mif {
  79.     local($handle) = @_;
  80.     local($line, $tmp);
  81.     local($old) = select($handle);
  82.  
  83.     while (!eof($handle)) {
  84.     #--------------#
  85.     # Get next '<' #
  86.     #--------------#
  87.     $/ = $mso;  $line = <$handle>;
  88.     &delete_comments(*line) unless $fast;
  89.     GETMSO: while (1) {
  90.         if (eof($handle)) {                # Break if EOF
  91.         $line .= "\n";
  92.         last GETMSO;
  93.         } elsif ($line !~ /$mso$/o) {        # MSO in comment
  94.         $/ = "\n";  <$handle>;  $/ = $mso;
  95.         $line .= "\n";
  96.         next GETMSO;
  97.         } elsif ($line =~ /\n$idlo.*$mso$/o) {    # Import data
  98.         next GETMSO;
  99.         } else {
  100.         last GETMSO;
  101.         }
  102.     } continue {
  103.         $tmp = <$handle>;
  104.         &delete_comments(*tmp) unless $fast;
  105.         $line .= $tmp;
  106.     }
  107.     &check_importdata(*line, 'check_closures')
  108.         if !$no_import_data && $OpenTokens[$#OpenTokens] eq 'ImportObject';
  109.     $carry = $line;
  110.     &check_closures(*line);
  111.     last if eof($handle);
  112.  
  113.     #--------------#
  114.     # Get next '>' #
  115.     #--------------#
  116.     $/ = $msc;  $line = <$handle>;
  117.     &delete_comments(*line) unless $fast;
  118.     GETMSC: while (1) {
  119.         if ($line !~ /$msc$/o) {              # MSC in comment
  120.         $/ = "\n";  <$handle>;  $/ = $msc;
  121.         $line .= "\n";
  122.         next GETMSC;
  123.         } elsif ($line =~ /\\$msc$/o ||        # Escaped MSC
  124.              $line =~ /\n$idlo.*$msc$/o) {    # Import data
  125.         next GETMSC;
  126.         } else {
  127.         last GETMSC;
  128.         }
  129.     } continue {
  130.         $tmp = <$handle>;
  131.         &delete_comments(*tmp) unless $fast;
  132.         $line .= $tmp;
  133.     }
  134.     &check_importdata(*line, 'check_opens') unless $no_import_data;
  135.     &check_opens(*line);
  136.  
  137.     #------------------------------------------------------------#
  138.     # At this point, there is only a statement with non-MIF data #
  139.     #------------------------------------------------------------#
  140.     if ($rm_Store) {
  141.         $stline .= $carry . $line;
  142.     } elsif (!$rm_Ignore) {
  143.         chop $line;            # Discard '>'
  144.         $line =~ s/^\s*(\S+)\s*//;    # Get token
  145.         $token = $1;
  146.         if ($func = $MIFToken{$token}) {
  147.         ($func) = (split(/[,\s]+/, $func))[1] if $func =~ /^$MStore/o;
  148.         &$func($token, $MLine, *line) if $func;
  149.         }
  150.     }
  151.     }
  152.     $/ = "\n";
  153.     select($old);
  154. }
  155. ##---------------------------------------------------------------------------##
  156. ##    check_closures() checks for any closures in *line.
  157. ##
  158. sub check_closures {
  159.     local(*line) = @_;
  160.     local($tmp);
  161.  
  162.     while ($line =~ s/^([^$msc]*$msc)//o) {
  163.     $tmp = $1;
  164.     $token = pop(@OpenTokens);    # Pop token off stack
  165.     die "Unexpected token closure, Empty Stack ($token):\n",
  166.         "$tmp$line\n"
  167.         unless $token;
  168.  
  169.     ## See what to do depending on mode ##
  170.     if ($rm_Store) {    # Store mode
  171.         $stline .= $tmp;        # Append $tmp to stored text
  172.         $rm_Store--;        # Decrement counter
  173.         if (!$rm_Store) {        # Store token closed
  174.         $line =~ s/^([^$msc$mso\n]*\n?)//o;     # Grab 'til end-of-line
  175.         $stline .= $1;                    # Append it.
  176.         &$stfunc($token, $MClose, *stline);     # Call store function
  177.         $stline = "";                    # Reset store text
  178.         } else {
  179.         $carry = $line;
  180.         }
  181.     } elsif (!$rm_Ignore && $MIFToken{$token}) {
  182.         $func = $MIFToken{$token};
  183.         &$func($token, $MClose)
  184.         unless $func =~ /^$MStore/o;
  185.     } else {
  186.         $rm_Ignore-- if $rm_Ignore;
  187.     }
  188.     }
  189. }
  190. ##---------------------------------------------------------------------------##
  191. ##    check_opens() checks for any opening tokens in *line.
  192. ##
  193. sub check_opens {
  194.     local(*line) = @_;
  195.     local($tmp);
  196.  
  197.     while ($line =~ s/^([^$stb$mso]*$mso)//o) {
  198.     $tmp = $1;
  199.     if ($tmp =~ /^\s*([^$mso\s]+)/o) {
  200.         $token = $1;
  201.     } else {        # Just whitespace
  202.         if ($rm_Store) {
  203.         $stline .= $carry . $tmp;
  204.         $carry = "";
  205.         }
  206.         next;        # Continue at top of loop
  207.     }
  208.     push(@OpenTokens, $token);
  209.  
  210.     ## See what to do depending on mode ##
  211.     if ($rm_Store) {
  212.         $stline .= $carry . $tmp;
  213.         $carry = "";
  214.         $rm_Store++;
  215.     } elsif (!$rm_Ignore && ($func = $MIFToken{$token})) {
  216.         if ($func =~ /^$MStore/o) {
  217.         ($stfunc) = (split(/[,\s]+/, $func))[1];
  218.         $rm_Store++;
  219.         ($carry) = $carry =~ /([ \t\r\f]*$mso)$/o;
  220.         $stline = $carry . $tmp;
  221.         $carry = "";
  222.         } else {
  223.         &$func($token, $MOpen);
  224.         }
  225.     } else {
  226.         $rm_Ignore++;
  227.     }
  228.     }
  229. }
  230. ##---------------------------------------------------------------------------##
  231. ##    check_importdata() determines if there exists in imported data
  232. ##    in the string *line.  If there is, the function specified by
  233. ##    %MIFToken{$MImportData} is called if it is defined.
  234. ##
  235. sub check_importdata {
  236.     local(*line, $chkfunc) = @_;
  237.  
  238.     if ($line =~ /\n$ido/o) {
  239.     local($prev, $data);
  240.     do {
  241.         $line =~ s/^([^$ido]*$ido)//o;
  242.         $prev .= $1;
  243.     } while ($prev !~ /\n$ido$/o);
  244.     $data = chop $prev;
  245.     $line =~ s/^([^\000]*\n\s*$idcstr)//o;
  246.     $data .= $1;
  247.  
  248.     &$chkfunc(*prev);
  249.     if ($chkfunc eq 'check_opens' && $prev =~ /^\s*(\S+)\s*$/) {
  250.         $token = $1;
  251.         push(@OpenTokens, $token);
  252.         if ($rm_Store) {
  253.         $stline .= $carry . $prev;
  254.         $prev = "";  $carry = "";
  255.         $rm_Store++;
  256.         } elsif (!$rm_Ignore && ($func = $MIFToken{$token})) {
  257.         if ($func =~ /^$MStore/o) {
  258.             ($stfunc) = (split(/[,\s]+/, $func))[1];
  259.             $rm_Store++;
  260.             ($carry) = $carry =~ /([ \t\r\f]*$mso)$/o;
  261.             $stline = $carry . $prev;
  262.             $carry = "";  $prev = "";
  263.         } else {
  264.             &$func($token, $MOpen);
  265.         }
  266.         } else {
  267.         $rm_Ignore++;
  268.         }
  269.     }
  270.  
  271.     if ($rm_Store) {
  272.         $stline .= $prev . $data;
  273.     } elsif (!$rm_Ignore && ($func = $MIFToken{$MImportData})) {
  274.         &$func($MImportData, $MLine, *data);
  275.     }
  276.     }
  277. }
  278. ##---------------------------------------------------------------------------##
  279. ##    delete_comments() removes any end-of-line comments.  Care must be
  280. ##    taken when the $como character appears in strings and when there
  281. ##    is import data.
  282. ##
  283. sub delete_comments {
  284.     local(*txt) = @_;
  285.     local(@array) = split(/\n/, $txt);
  286.  
  287.     foreach (@array) {
  288.     next if $_ !~ /$como/o ||    # Continue if no '#'
  289.         /^\s*$idlo/o ||        # Ignore import data
  290.         s/^\s*$como.*$//o;    # Comment line
  291.  
  292.     s/^([^$stb]*)$como.*$/\1/o;
  293.     s/^([^$ste]*$ste[^$como]*)$como.*$/\1/o;
  294.     }
  295.     $txt = join("\n", @array);
  296. }
  297. ##---------------------------------------------------------------------------##
  298.  
  299. ###############################################################################
  300. ##               CORE MIF OUTPUT ROUTINES                 ##
  301. ###############################################################################
  302.  
  303. ##---------------------------------------------------------------------------
  304. sub main'MIFwrite_open {
  305.     local($handle, $token, $indent) = @_;
  306.     local($i0) = (' ' x $indent);
  307.     print $handle $i0, $mso, $token, "\n";
  308. }
  309. ##---------------------------------------------------------------------------
  310. sub main'MIFwrite_close {
  311.     local($handle, $indent) = @_;
  312.     local($i0) = (' ' x $indent);
  313.     print $handle $i0, $msc, "\n";
  314. }
  315. ##---------------------------------------------------------------------------
  316. sub main'MIFwrite_statment {
  317.     local($handle, $token, $data, $indent) = @_;
  318.     local($i0) = (' ' x $indent);
  319.     print $handle $i0, $mso, $token, ' ', $data, $msc, "\n";
  320. }
  321. ##---------------------------------------------------------------------------
  322. sub main'MIFwrite_str_statment {
  323.     local($handle, $token, $data, $indent) = @_;
  324.     local($i0) = (' ' x $indent);
  325.     print $handle $i0, $mso, $token, ' ', $stb, $data, $ste, $msc, "\n";
  326. }
  327. ##---------------------------------------------------------------------------
  328. ##    MIFescape_string() converts certain characters in string *str to
  329. ##    Frame backslash sequences.
  330. ##
  331. sub main'MIFescape_string {
  332.     local(*str) = shift;
  333.     $str = s/\\/\\\\/g;
  334.     $str = s/\t/\\t/g;
  335.     $str = s/>/\\>/g;
  336.     $str = s/'/\\q/g;
  337.     $str = s/`/\\Q/g;
  338. }
  339. ##---------------------------------------------------------------------------##
  340.  
  341. 1;
  342.